perm filename EPAR3A.2[EAL,HE] blob
sn#704701 filedate 1983-03-31 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00006 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 {$NOMAIN Editor: Aux routines for parsing }
C00005 00003 (* assignParse *)
C00012 00004 (* forParse *)
C00016 00005 (* affixParse & unfixParse *)
C00024 00006 (* enableParse *)
C00027 ENDMK
C⊗;
{$NOMAIN Editor: Aux routines for parsing }
%include eparse.hdr;
{ Externally defined routines from elsewhere: }
(* From ALLOC *)
function newNode: nodep; external;
procedure relNode(n: nodep); external;
(* From EROOT *)
function e3aExprParse: nodep; external;
(* From EAUX1A *)
function makeUVar(vartype: datatypes; vid: identp): varidefp; external;
function varLookup(id: identp): varidefp; external;
(* From EAUX1B *)
function defNode(d: datatypes): nodep; external;
function getDtype(n: nodep): datatypes; external;
function checkArg(n: nodep; d: datatypes): nodep; external;
(* From EAUX1C *)
procedure errprnt; external;
function getdim(n: nodep; var d: nodep): nodep; external;
function evalOrder(what,last: nodep; pcons: boolean): nodep; external;
(* From ETOKEN *)
procedure getToken; external;
procedure dimCheck(n,d: nodep); external;
(* From PP *)
procedure ppLine; external;
procedure ppOutNow; external;
procedure ppChar(ch: ascii); external;
procedure pp5(ch: c5str; length: integer); external;
procedure pp10(ch: cstring; length: integer); external;
procedure pp10L(ch: cstring; length: integer); external;
procedure pp20(ch: c20str; length: integer); external;
procedure pp20L(ch: c20str; length: integer); external;
procedure ppInt(i: integer); external;
procedure ppReal(r: real); external;
procedure ppStrng(length: integer; s: strngp); external;
procedure ppDtype(d: datatypes); external;
procedure ppDelChar; external;
procedure ePar3aGet; external;
procedure ePar3aGet; begin end;
(* assignParse *)
procedure assignParse(st: statementp; np: nodep); external;
procedure assignParse;
var n,dp: nodep; d1,d2: datatypes; b: boolean;
begin
with st↑ do
begin
exprs := nil;
aval := nil;
bad := false; (* assume statement is ok *)
if np <> nil then what := np (* use previously parsed node *)
else what := e3aExprParse; (* see what we're assigning to *)
if what <> nil then
with what↑ do
begin
b := false;
n := nil;
if (ntype = leafnode) and (ltype = varitype) then n := what
else b := not ((ntype = exprnode) and
((op = callop) or (op = arefop) or (op = dacop)) );
if b and (ntype = exprnode) and
((op = tposop) or (op = torientop) or (op = deproachop)) then
if (arg1↑.ntype = leafnode) and (arg1↑.ltype = varitype) then
begin b := false; n := arg1 end
else b := not ((arg1↑.ntype = exprnode) and (arg1↑.op = arefop));
if n <> nil then (* make sure it's not a device *)
if n↑.vari↑.level = 0 then
b := n↑.vari↑.offset in [0,2,4,6,8,12];
(* offsets: arms: 0,4 hands: 2,6 driver/vise: 8,12 *)
if b then
begin (* no good *)
if n = nil then
begin
pp20L(' Can only assign to ',20); pp10('a variable',10);
end
else
begin
pp20L(' Can''t assign values',20); pp20(' to devices ',11);
end;
errPrnt;
bad := true; (* mark statement as bad *)
end
else if (ntype = exprnode) and ((op = callop) or (op = dacop)) then
begin
if op = callop then stype := calltype;
exprs := evalOrder(what,nil,true);
end
else if (ntype = leafnode) and (ltype = varitype) then
begin
if vari↑.vtype = undeftype then
begin
getToken;
backUp := true;
with curToken do
if (ttype = delimtype) and (ch = ';') then
begin
vari↑.tbits := 2; (* make it a procedure *)
vari↑.p := nil;
n := newNode;
with n↑ do
begin
ntype := exprnode;
op := callop;
arg1 := what;
arg2 := nil;
arg3 := nil;
next := nil;
end;
what := n;
stype := calltype;
exprs := nil;
end
end
end;
end;
if stype = assigntype then
begin
getToken; (* look for the ":=" *)
with curToken do
if (ttype <> reswdtype) or (rtype <> stmnttype) or
(stmnt <> assigntype) then
begin
backUp := true;
pp20L(' Expecting ":=" here',20); errPrnt;
end;
aval := e3aExprParse;
if (what <> nil) and (aval <> nil) then
begin
d1 := getDtype(what);
d2 := getDtype(aval);
if d1 = undeftype then
begin
if (d2 = transtype) and (aval↑.ntype = exprnode) then
with aval↑ do (* check if it shouldn't really be a frame *)
if (op = constrop) or (op = fmakeop) then d2 := frametype
else if (ttmulop <= op) and (op <= tvsubop) then d2 := getDtype(arg1);
d1 := d2;
if what↑.ntype = leafnode then what↑.vari↑.vtype := d1
else what↑.arg1↑.vari↑.vtype := d1;
end;
if d2 = undeftype then
begin
d2 := d1;
if aval↑.ntype = leafnode then aval↑.vari↑.vtype := d2
else aval↑.arg1↑.vari↑.vtype := d2;
end;
if (d1 = frametype) or (d1 = rottype) then d1 := transtype;
if (d2 = frametype) or (d2 = rottype) then d2 := transtype;
if d1 <> d2 then
begin (* no good *)
b := true;
pp20L(' Can''t assign a ',16); ppDtype(d2);
pp10(' to a ',6); ppDtype(d1); errPrnt;
n := newNode;
with n↑ do
begin
ntype := exprnode;
op := badop;
arg1 := aval;
arg2 := defNode(d1);
arg3 := nil;
end;
aval := n;
end
else
begin
dp := nil;
dimCheck(aval,getDim(what,dp));
relNode(dp);
with what↑ do
if ntype = leafnode then n := nil
else if op = arefop then n := arg2
else if arg1↑.ntype = leafnode then n := nil
else n := arg1↑.arg2;
if n <> nil then
n := evalorder(n,nil,true); (* deal with subscripts *)
exprs := evalorder(aval,n,true);
end;
end
else if aval <> nil then
begin
backUp := true;
bad := true; (* mark statement as bad *)
pp20L(' Expecting an expres',20); pp10('sion here ',9); errPrnt;
end
end;
end;
end;
(* forParse *)
procedure forParse(st: statementp); external;
procedure forParse;
var lexp,dim: nodep; b: boolean;
begin
with st↑ do
begin
b := false;
forvar := checkArg(e3aExprParse,svaltype); (* get the for variable *)
initial := nil;
step := nil;
final := nil;
dim := nil;
with forvar↑ do (* make sure it's a variable *)
if not (((ntype = leafnode) and (ltype = varitype)) or
((ntype = exprnode) and (op = arefop))) then
begin (* no good *)
bad := true; (* mark it as no good *)
pp20L(' Need a scalar varia',20); pp10('ble here. ',9); errprnt;
end
else bad := false;
dim := getdim(forvar,dim);
getToken; (* look for the ":=" *)
with curToken do
if (ttype <> reswdtype) or (rtype <> stmnttype) or (stmnt <> assigntype) then
begin
backUp := true;
pp20L(' Expecting ":=" here',20); errprnt;
end;
initial := checkArg(e3aExprParse,svaltype); (* get the initial value *)
dimCheck(initial,dim);
getToken; (* look for the "STEP" *)
with curToken do
if (ttype <> reswdtype) or (rtype <> filtype) or (filler <> steptype) then
begin
backUp := true;
pp20L(' Expecting a "STEP" ',20); pp5('here.',5); errprnt;
end;
step := checkArg(e3aExprParse,svaltype); (* get the step value *)
dimCheck(step,dim);
getToken; (* look for the "TO" *)
with curToken do
if (ttype <> reswdtype) or (rtype <> filtype) or (filler <> untltype) then
begin
backUp := true;
pp20L(' Expecting an "UNTIL',20); pp10('" here. ',7); errPrnt;
end;
final := checkArg(e3aExprParse,svaltype); (* get the final value *)
dimCheck(final,dim);
with forvar↑ do
if ntype = leafnode then lexp := nil
else lexp := evalOrder(arg2,nil,true); (* push array subscripts *)
lexp := evalOrder(initial,lexp,true);
lexp := evalOrder(step,lexp,true);
exprs := evalOrder(final,lexp,true);
if dim <> nil then relNode(dim);
end;
end;
(* affixParse & unfixParse *)
procedure affixParse(st: statementp); external;
procedure affixParse;
var opt,b: boolean; lexp: nodep; (*hack*) b1,b2: boolean;
begin
with st↑, curToken do
begin
bad := false;
if fieldNum = 1 then
begin
frame1 := checkArg(e3aExprParse,frametype);
with frame1↑ do (* make sure it's a variable *)
(* Fix for OMSI *)
begin
b1 := ((ntype = leafnode) and (ltype = varitype));
b2 := ((ntype = exprnode) and (op = arefop));
if not (b1 or b2) then
begin (* no good *)
pp20L(' Need a frame variab',20); pp10('le here. ',8); errPrnt;
bad := true; (* mark it as no good *)
end;
end;
getToken; (* look for the "TO" *)
if (ttype <> reswdtype) or (rtype <> filtype) or (filler <> totype) then
begin
backUp := true;
pp20L(' Expecting "TO" here',20); errPrnt;
end;
frame2 := checkArg(e3aExprParse,frametype);
with frame2↑ do (* make sure it's a variable *)
(* Fix for OMSI *)
begin
b1 := ((ntype = leafnode) and (ltype = varitype));
b2 := ((ntype = exprnode) and (op = arefop));
if not (b1 or b2) then
begin (* no good *)
pp20L(' Expecting "TO" here',20); errPrnt;
bad := true; (* mark it as no good *)
end;
end;
opt := true;
byvar := nil;
if nlines = 1 then atexp := nil; (* may not be editing this now *)
rigid := true; (* default flavor affixment *)
while opt do
begin (* now look for optional parts: AT, BY & how *)
getToken;
if (ttype = reswdtype) and (rtype = filtype) and (filler = bytype) then
begin
byvar := checkArg(e3aExprParse,transtype); (* get the BY var *)
dimCheck(byvar,distancedim↑.dim);
with byvar↑ do (* make sure it's a variable *)
begin
b := ((ntype <> leafnode) or (ltype <> varitype));
if b then b := ((ntype <> exprnode) or (op <> arefop));
end;
if b then
begin (* no good *)
bad := true; (* mark it as no good *)
pp20L(' Need a trans variab',20); pp10('le here. ',8); errPrnt;
end
end
else if (ttype = reswdtype) and (rtype = filtype) and
(filler = attype) then
begin
atexp := checkArg(e3aExprParse,transtype); (* get the AT expression *)
dimCheck(atexp,distancedim↑.dim);
end
else if (ttype = reswdtype) and (rtype = filtype) and
(filler = rigidlytype) then rigid := true
else if (ttype = reswdtype) and (rtype = filtype) and
(filler = nonrigidlytype) then rigid := false
else opt := false;
end;
end
else
begin
atexp := checkArg(e3aExprParse,transtype); (* get the AT expression *)
dimCheck(atexp,distancedim↑.dim);
end;
with frame1↑ do
if ntype = leafnode then lexp := nil
else lexp := evalOrder(arg2,nil,true); (* push array subscripts *)
with frame2↑ do
if ntype <> leafnode then lexp := evalOrder(arg2,lexp,true);
if byvar <> nil then
with byvar↑ do
if ntype <> leafnode then lexp := evalOrder(arg2,lexp,true);
if atexp <> nil then exprs := evalOrder(atexp,lexp,true)
else exprs := lexp;
end;
end;
procedure unfixParse(st: statementp); external;
procedure unfixParse;
var lexp: nodep;
begin
with st↑ do
begin
bad := false;
frame1 := checkArg(e3aExprParse,frametype);
with frame1↑ do (* make sure it's a variable *)
if not (((ntype = leafnode) and (ltype = varitype)) or
((ntype = exprnode) and (op = arefop))) then
begin (* no good *)
pp20L(' Need a frame variab',20); pp10('le here. ',8); errPrnt;
bad := true; (* mark it as no good *)
end;
getToken; (* look for the "FROM" *)
with curToken do
if (ttype <> reswdtype) or (rtype <> filtype) or (filler <> fromtype) then
begin
backUp := true;
pp20L(' Expecting a "FROM" ',20); pp5('here.',5); errPrnt;
end;
frame2 := checkArg(e3aExprParse,frametype);
with frame2↑ do (* make sure it's a variable *)
if not (((ntype = leafnode) and (ltype = varitype)) or
((ntype = exprnode) and (op = arefop))) then
begin (* no good *)
pp20L(' Need a frame variab',20); pp10('le here. ',8); ppLine;
bad := true; (* mark it as no good *)
end;
with frame1↑ do
if ntype = leafnode then lexp := nil
else lexp := evalOrder(arg2,nil,true); (* push array subscripts *)
with frame2↑ do
if ntype <> leafnode then exprs := evalOrder(arg2,lexp,true)
else exprs := lexp;
byvar := nil;
atexp := nil;
end;
end;
(* enableParse *)
procedure enableParse(st: statementp); external;
procedure enableParse;
var v: varidefp; b: boolean; i: integer;
begin
with st↑ do
begin
cmonlab := nil;
with curToken do
begin
getToken; (* get the label of the cmon to enable/disable *)
if ttype = identtype then (* check that it's really a label *)
begin
v := varLookup(id);
if v = nil then
begin (* need to define it *)
v := makeUVar(labeltype,id);
(* ??? where will we check that it gets used as a label ??? *)
cmonlab := v;
pp20L(' Undeclared identifi',20);
pp20('er defined to be a l',20); pp5('abel.',5); errPrnt;
end
else if v↑.vtype = labeltype then cmonlab := v (* ok *)
else b := true (* no good *)
end
else
begin
i := cursor;
b := true; (* no good, unless in a cmon body *)
while (i > 1) and b do
with cursorStack[i] do
if stmntp then
if st↑.stype = cmtype then b := false (* found it *)
else i := i - 1
else i := i - 1;
end;
end;
if b then
begin (* no good *)
pp20L(' Need a label here. ',19); errPrnt;
bad := true; (* mark statement as bad *);
end
else bad := false;
end;
end;